(* ===================================================================== *)
(** Outils communs au application meta (bopipe, bopin) 
    @author Mathieu Barbin
    @version 1.0.* *)
(* ===================================================================== *)

open BplibTypes
open Bplib
open Message
open Inputtools

(* ===================================================================== *)
(** Le type des variables representant les signaux dans un fichier bp    *)
(* ===================================================================== *)
type bp_var = 
  | VBit of string
  | VWord of string * string array
(* ===================================================================== *)

(* ===================================================================== *)
(** Quel peut etre la nature du code source utilise dans un fichier bp  *)
(* ===================================================================== *)
type bp_source = Ocaml | C | Autre of string | Inconnu of string
(* ===================================================================== *)

(* ===================================================================== *)
(** Bopin, Bopipe et les langages ... 
    Determiner la reaction a donner a un langage *)
(* ===================================================================== *)
let autres_langages =
  let aux = 
    [
      "python";"ruby";"lua";"perl";"java";"scheme";"c++";"c#";"pascal";"prolog";"eiffel"
    ]
  in aux @ (List.map String.capitalize aux);;

let bp_source_of_string = function
  | "ocaml" | "Ocaml" -> Ocaml
  | "c" | "C" -> C
  | autre when List.mem autre autres_langages -> Autre autre
  | i -> Inconnu i
(* ===================================================================== *)

(* ===================================================================== *)
(** Standard Debugging BOPIN & BOPIPE library : proposer par defaut des 
    fonctions utiles pour ne pas les definir à chaque nouveau fichier bp *) 
(* ===================================================================== *)
let ocaml_args_assoc = "let args_assoc = assoc_of_sys_argv Sys.argv;;\n\n";;
let ocaml_get_arg_int_value = "let get_arg_int_value = try_get_arg_int_value args_assoc;;\n";;
let ocaml_get_arg_string_value = "let get_arg_string_value = try_get_arg_string_value args_assoc;;\n";;
(* ===================================================================== *)

let stdlibBP = 
  List.fold_left (^) "" 
[
  ocaml_args_assoc;
  ocaml_get_arg_int_value;
  ocaml_get_arg_string_value
];;


(* ===================================================================== *)
(** Production de code pour une expression en vérifiant qu'il n'y ait pas 
    de probleme de FreeVar *)
(* ===================================================================== *)
let safe_string_of_expr env =
  let fct s = "_"^s in
  let rec aux = function
    | VAR s -> if List.mem s env then fct s else raise (FreeVar s)
    | CST c -> string_of_int c
    | ADD (a, b) -> Printf.sprintf "((%s)+(%s))" (aux a) (aux b)
    | SUB (a, b) -> Printf.sprintf "((%s)-(%s))" (aux a) (aux b)
    | DIV (a, b) -> Printf.sprintf "((%s)/(%s))" (aux a) (aux b) 
    | MULT (a, b) -> Printf.sprintf "((%s)*(%s))" (aux a) (aux b)
    | MOD (a, b) -> Printf.sprintf "((%s) mod (%s))" (aux a) (aux b)
    | EXP (a, b) -> Printf.sprintf "((%s) $$ (%s))" (aux a) (aux b)
    | MIN (a, b) -> Printf.sprintf "(min (%s) (%s))" (aux a) (aux b)
    | MAX (a, b) -> Printf.sprintf "(max (%s) (%s))" (aux a) (aux b) 
    | LOG e -> Printf.sprintf "(log2 (%s))" (aux e) 
  in aux
(* ===================================================================== *)

(* ===================================================================== *)
(** Production de code pour une expression sans aucune vérification. *)
(* ===================================================================== *)
let unsafe_string_of_expr =
  let rec aux = function 
    | VAR s -> s
    | CST c -> string_of_int c
    | ADD (a, b) -> Printf.sprintf "((%s)+(%s))" (aux a) (aux b)
    | SUB (a, b) -> Printf.sprintf "((%s)-(%s))" (aux a) (aux b)
    | DIV (a, b) -> Printf.sprintf "((%s)/(%s))" (aux a) (aux b) 
    | MULT (a, b) -> Printf.sprintf "((%s)*(%s))" (aux a) (aux b)
    | MOD (a, b) -> Printf.sprintf "((%s) mod (%s))" (aux a) (aux b)
    | EXP (a, b) -> Printf.sprintf "((%s) $$ (%s))" (aux a) (aux b)
    | MIN (a, b) -> Printf.sprintf "(min (%s) (%s))" (aux a) (aux b)
    | MAX (a, b) -> Printf.sprintf "(max (%s) (%s))" (aux a) (aux b) 
    | LOG e -> Printf.sprintf "(log2 (%s))" (aux e) 
  in aux
(* ===================================================================== *)


(* ===================================================================== *)
(** Production de code pour une expression conditionnelle en vérifiant 
    qu'il n'y ait pas de probleme de FreeVar *)
(* ===================================================================== *)
let general_string_of_concition_expr fct_expr =
  let rec aux = function
    | CONST e -> Printf.sprintf "(%s <> 0)" (fct_expr e) 
    | COND_EQ (e1, e2) -> Printf.sprintf "(%s = %s)" (fct_expr e1) (fct_expr e2)
    | COND_NEQ (e1, e2) -> Printf.sprintf "(%s <> %s)" (fct_expr e1) (fct_expr e2) 
    | COND_PP (e1, e2) -> Printf.sprintf "(%s <= %s)" (fct_expr e1) (fct_expr e2) 
    | COND_PG (e1, e2) -> Printf.sprintf "(%s >= %s)" (fct_expr e1) (fct_expr e2) 
    | COND_SPP (e1, e2) -> Printf.sprintf "(%s < %s)" (fct_expr e1) (fct_expr e2) 
    | COND_SPG (e1, e2) -> Printf.sprintf "(%s > %s)" (fct_expr e1) (fct_expr e2) 
    | COND_NEG (e1) -> Printf.sprintf "not(%s)" (aux e1)
    | COND_OR (e1, e2) -> Printf.sprintf "(%s || %s)" (aux e1) (aux e2) 
    | COND_AND (e1, e2) -> Printf.sprintf "(%s && %s)" (aux e1) (aux e2) 
  in aux

let safe_string_of_condition_expr env = general_string_of_concition_expr (safe_string_of_expr env) 
let unsafe_string_of_condition_expr = general_string_of_concition_expr unsafe_string_of_expr
(* ===================================================================== *)

(* ===================================================================== *)
(** Meta programmation des fonctions d'extraction des signaux depuis le 
    protocole pipe01 dans stdin & stdout *)
(* ===================================================================== *)
let prod_extract_signal s d = Printf.sprintf "bool_of_char %s.[%s]" s d;;

let acces_n pref i d = 
  let accu = ref pref in 
  for j = 0 to pred d do
    accu:=(!accu)^(Printf.sprintf ".(%s%d)" i j)
  done;
  !accu;;

let calcul_n i tab = 
  let len = Array.length tab in
  let tab_coef = Array.make len "1" in
  begin
    for i = 0 to pred len do
      for j = succ i to pred len do
	tab_coef.(i) <- (Printf.sprintf "(%s * %s)" tab_coef.(i) tab.(j))
      done
    done;
    let accu = ref (Printf.sprintf "%s * %s0" tab_coef.(0) i) in
    for j = 1 to pred len do
      accu := Printf.sprintf "%s + %s * %s%d" (!accu) tab_coef.(j) i j 
    done;
    !accu
  end;;

let prod_extract_signal_array s index tab =
  let n = Array.length tab in
  (* Allocation d'un tableau de bool de dimension n > 1 *)
  let rec aux i =
    if i = pred n 
    then
      Printf.sprintf "Array.make %s false; for i%d = 0 to pred (%s) do %s <- bool_of_char %s.[%s + (!%s)]; done; " 
	tab.(i) i tab.(i) (acces_n "tab_tmp" "i" n) s (calcul_n "i" tab) index
    else
      Printf.sprintf "Array.make %s [||]; for i%d = 0 to pred (%s) do %s <- %sdone; " 
	tab.(i) i tab.(i) (acces_n "tab_tmp" "i" (succ i)) (aux (succ i)) 
  in 
  if n = 1 
  then
    (Printf.sprintf "let tab_tmp = Array.make %s false in ( for i0 = 0 to pred (%s) do %s <- bool_of_char %s.[i0+(!%s)] done; tab_tmp ) "
    tab.(0) tab.(0) "tab_tmp.(i0)" s index)
  else
    (Printf.sprintf "let tab_tmp = Array.make %s [||] in ( for i0 = 0 to pred (%s) do %s <- %sdone; tab_tmp ) " tab.(0) tab.(0) "tab_tmp.(i0)" (aux 1))
;;

(* valeur * index ref * length tab *)
let prod_extract_signal_array_cst value index tab =
  let n = Array.length tab in
  (* Allocation d'un tableau de bool de dimension n > 1 *)
  let rec aux i =
    if i = pred n 
    then
      Printf.sprintf "Array.make %s %s; " tab.(i) value
    else
      Printf.sprintf "Array.make %s [||]; for i%d = 0 to pred (%s) do %s <- %sdone; " 
	tab.(i) i tab.(i) (acces_n "tab_tmp" "i" (succ i)) (aux (succ i)) 
  in 
  if n = 1 
  then (Printf.sprintf "Array.make %s %s " tab.(0) value)
  else
    (Printf.sprintf "let tab_tmp = Array.make %s [||] in ( for i0 = 0 to pred (%s) do %s <- %sdone; tab_tmp ) " tab.(0) tab.(0) "tab_tmp.(i0)" (aux 1))
;;

let length_of_indexation env = function
  | SegmentInit exp -> 
      let i = safe_string_of_expr env exp in
      Printf.sprintf "(let i = %s in if i < 0 then (-i) else i)" i
  | Intervalle (e1, e2) ->
      let i1 = safe_string_of_expr env e1 in
      let i2 = safe_string_of_expr env e2 in
      Printf.sprintf "(let i1 = %s and i2 = %s in if i1 <= i2 then i2 - i1 + 1 else i1 - i2 + 1)" i1 i2
  | Index _ -> "1"
;;

let string_exists fct s =
  let len = String.length s in
  let r = ref false in
  let i = ref 0 in
  while (not(!r) && (!i < len)) do
    if fct s.[!i] then r:=true else incr(i)
  done;
  !r

let verifie_ocaml_vars filename methode list =
  let var_ok s = (String.length s > 0 && (int_of_char s.[0] >= 95) && (int_of_char s.[0] <= 122) && (not (string_exists (fun t -> t = '~') s))) in
  let f_fold accu = function
    | VBit s | VWord (s, _) ->
	if not (var_ok s)
	then 
	  begin
	    Message.message#not_ocaml_var filename s;
	    failwith "w-friendly"
	  end
	else 
	  if List.mem s accu 
	  then
	    begin
	      Message.message#definition_multiple_ocaml_var filename methode s;
	      failwith "w-friendly"
	    end
	  else (s::accu) 	
  in ignore (List.fold_left f_fold [] list)

let bp_var_of_var env = function
  | Fresh _ -> failwith "Fresh var in bp_var_of_var"
  | Simple s -> VBit s
  | Vecteur (ligne, name, indlist) ->
      let length_tab = 
	try
	  Array.of_list (List.map (length_of_indexation env) indlist)
	with
	| FreeVar v -> 
	    Message.message#free_meta_var (Printf.sprintf "Interface BP : %s" name) ligne v;
	    failwith "w-friendly"
	| TypeClash m ->
	    Message.message#type_clash (Printf.sprintf "Interface BP : %s" name) ligne m;
	    failwith "w-friendly"
      in VWord (name, length_tab);;

let fold_init fct ac num =
  let rec aux accu i = 
    if i >= num
    then accu
    else aux (fct accu i) (succ i)
  in aux ac 0;;

let meta_instruction_tab instr var tab =
  let len = Array.length tab in
  let f_fold_init_var accu i = Printf.sprintf "%s.(i%d)" accu i in
  let f_fold_init_for accu i = Printf.sprintf "%sfor i%d = 0 to pred (%s) do\n" accu i tab.(i) in
  let f_fold_init_done accu i = Printf.sprintf "%sdone;\n" accu in
  Printf.sprintf "%s%s %s\n%s" 
    (fold_init f_fold_init_for "" len)
    instr
    (fold_init f_fold_init_var var len)
    (fold_init f_fold_init_done "" len)
;;

(* ===================================================================== *)

(* ===================================================================== *)  
(** Produire le code d'entete (liaisons des signaux avec lecture sur stdin)*)
(* ===================================================================== *)  
let produce_entete_code_in q index v = 
  let rec aux = function
    | VBit s -> 
	let metaS = 
	  Printf.sprintf "let %s = %s in\n" s (prod_extract_signal "_META_line" ("!"^index))
	in 
	begin
	  Queue.add metaS q;
	  Queue.add (Printf.sprintf "incr(%s);\n" index) q
	end 
    | VWord (name, length_tab) -> 
	let metaS = 
	  Printf.sprintf "let %s = %sin\n" name 
	    (prod_extract_signal_array "_META_line" index length_tab)
	in 
	begin
	  let plus = "+"^(Array.fold_left (fun accu t -> accu^"*"^t) "1" length_tab) in
	  Queue.add metaS q;
	  Queue.add (Printf.sprintf "%s:=((!%s)%s);\n" index index plus) q
	end
  in aux v;;

(* La seule difference est que les signaux simples sont des references *)
let produce_entete_code_out q index v = 
  let rec aux = function
    | VBit s -> 
	let metaS = Printf.sprintf "let %s = ref false in\n" s in 
	Queue.add metaS q 
    | VWord (name, length_tab) -> 
	let metaS = 
	  Printf.sprintf "let %s = %sin\n" name 
	    (prod_extract_signal_array_cst "false" index length_tab)
	in 
	Queue.add metaS q
  in aux v;;

let verifie_arite arite filename =
  (Printf.sprintf "    let arite = %s in\n" arite)^
    (Printf.sprintf "    if arite <= 0 then () else\n")^ 
    (Printf.sprintf "    ( try ignore _META_line.[pred arite]\n")^
    "      with Invalid_argument _ ->\n"^
    (Printf.sprintf "        prerr_endline \"BLOC EXTERNE - PROCESSUS BOPIPE \\\"%s\\\" ERROR\";\n" filename)^
    (Printf.sprintf "        Printf.fprintf stderr \"Arite entrante insuffisante. ( < %cd ) \\n\" (%s);\n        flush stderr;\n" '%' arite)^
    "        exit 1\n"^
    "    );\n";; 

let num_bits_of_bp_var list = 
  let aux = function
    | VBit s -> "1"
    | VWord (_, length_tab) -> 
	"("^(fold_init (fun accu i -> (Printf.sprintf "%s * %s" accu length_tab.(i))) 
	       "1" (Array.length length_tab))^")"
  in 
  let f_fold accu v = (Printf.sprintf "%s + %s" accu (aux v)) in
  List.fold_left f_fold "0" list;;

let ocaml_entete_of_interface do_in do_out filename vars_in vars_out =
  let num_protocole = num_bits_of_bp_var ((if do_in then vars_in else [])@(if do_out then vars_out else [])) in 
  let index_read = "index_read" in
  let def_q = Queue.create () in
  let prod_in = produce_entete_code_in def_q index_read in
  let prod_out = produce_entete_code_out def_q index_read in
  List.iter prod_in vars_in;
  List.iter prod_out vars_out;
  let s_out = ref (if (do_in || do_out) then ((verifie_arite num_protocole filename)^"let index_read = ref 0 in\nignore(index_read);\n") else "") in
  for i = 0 to pred (Queue.length def_q) do
    s_out := !s_out^(Queue.pop def_q)
  done;
  !s_out;;
(* ===================================================================== *)  

let list_init n f = 
  let rec aux accu = function
    | 0 -> (f 0)::accu
    | o -> aux ((f o)::accu) (pred o)
  in aux [] (pred n);;

(*
let meta_instruction_tab instr var len_tab intercal =
  let len = Array.length len_tab in
  let rec aux accu i = 
    if i = len
    then accu
    else
      aux
	(concat_map (fun s -> 
		       if i = pred len
		       then
			 (list_init (succ len_tab.(i))
			    (fun k -> if k = len_tab.(i)
			     then intercal
			     else Printf.sprintf "%s.(%d)" s k))
		       else
			 (list_init len_tab.(i) 
			    (fun k -> Printf.sprintf "%s.(%d)" s k ))
		    ) accu 
	) (succ i)
  in aux [instr^" "^var] 0;;
*)

(* ===================================================================== *)
  
(* ===================================================================== *)
(** Produire le code d'affichage des signaux dans stderr. *)
(* ===================================================================== *)
let ocaml_traitement_stderr vars = 
  let aux = function 
    | VBit s ->
Printf.sprintf "Printf.fprintf stderr \"| %s=%cd |\" (int_of_bool %s);\n" s '%' s
    | VWord (s, tab) -> 
	(Printf.sprintf "Printf.fprintf stderr \"| %s=\";" s)^
	  (meta_instruction_tab (Printf.sprintf "(fun t -> Printf.fprintf stderr \"%cd\" (if t then 1 else 0))" '%') s tab)^
	  (Printf.sprintf "Printf.fprintf stderr \" |\";flush stderr;\n")
  in List.fold_left (fun accu t -> accu^(aux t)) "" vars;;

(*
  let print_list = meta_instruction_tab "prerr_bool" s tab "prerr_string \" \"" in
  (Printf.sprintf "Printf.fprintf stderr \"| %s=\";%sPrintf.fprintf stderr \"|\";\n" s (List.fold_left (fun accu t -> accu^t^";") "" print_list))
  in List.fold_left (fun accu t -> accu^(aux t)) "" vars;;
*) 

(** Produire le resultat d'un bloc externe en definition *)
let ocaml_traitement_stdout vars_out =  
  let aux = function 
    | VBit s -> Printf.sprintf "fff (!%s);\n" s
    | VWord (s, tab) ->	(meta_instruction_tab "fff" s tab) 
  in List.fold_left (fun accu t -> accu^(aux t)) "let fff t = print_string (if t then \"1\" else \"0\") in let ignore_fun (f:'a->unit) = () in ignore_fun(fff);\n" vars_out;; 
(* 
  let print_list = meta_instruction_tab "print_bool" s tab "()" in
  (List.fold_left (fun accu t -> accu^t^";") "" print_list)
  in List.fold_left (fun accu t -> accu^(aux t)) "" vars_out;;
*)
(* ===================================================================== *)


(* ===================================================================== *)
(** Produire les macros_BP : prefixée par _ (FxCop n'est pas d'accord 
    mais c'est pas si grave au fond ...) 
    Pourquoi on le fait : la plupart des macros commencent par une majuscule. *)
(* ===================================================================== *)
let ocaml_macro filename macroBP_list = 
  let f_fold (accustr, env) mac = 
    let ml_decl, new_env = 
      match mac with
      | MacDefine md ->
	  (match md.corps_macro with
	   | DefInt expr_macro -> 
	       begin
		 try
		   let ssoe = safe_string_of_expr env expr_macro in
		   (Printf.sprintf "_%s = %s  " md.nom_macro ssoe), md.nom_macro::env
		 with
		 | FreeVar v -> 
		     Message.message#free_meta_var filename md.ligne_macro v; 
		     failwith "w-friendly"
		 | TypeClash m -> 
		     Message.message#type_clash filename md.ligne_macro m; 
		     failwith "w-friendly"      
	       end
	   | DefString s ->
	       (
		 try
		   Printf.sprintf "_%s = \"%s\"  " md.nom_macro s, env (* FIXME : META COMMAND TEST ? *)
		 with
		 | FreeVar v -> 
		     Message.message#free_meta_var filename md.ligne_macro v; 
		     failwith "w-friendly"
		 | TypeClash m -> 
		     Message.message#type_clash filename md.ligne_macro m; 
		     failwith "w-friendly"
	       ) 	 
	   | DefCondInt (_if, _then, _else) ->
	       (
		 try 
		   let _if_string = safe_string_of_condition_expr env _if in
		   let _then_string = safe_string_of_expr env _then in
		   let _else_string = safe_string_of_expr env _else in
		   (Printf.sprintf "_%s = if %s then %s else %s " md.nom_macro _if_string _then_string _else_string), md.nom_macro::env
		 with
		 | FreeVar v -> 
		     Message.message#free_meta_var filename md.ligne_macro v; 
		     failwith "w-friendly"
		 | TypeClash m -> 
		     Message.message#type_clash filename md.ligne_macro m; 
		     failwith "w-friendly" 
	       )
	   | DefCondString (_if, _then, _else) ->
	       (
		 try
		   let _if_string = safe_string_of_condition_expr env _if in
		   Printf.sprintf "_%s = if %s then %s else %s " md.nom_macro _if_string _then _else, env (* FIXME : META COMMAND *)
		 with
		 | FreeVar v -> 
		     Message.message#free_meta_var filename md.ligne_macro v; 
		     failwith "w-friendly"
		 | TypeClash m -> 
		     Message.message#type_clash filename md.ligne_macro m; 
		     failwith "w-friendly"
	       ) 
	  )
      | MacIntArg (lig, arg) -> 
	  (Printf.sprintf "_%s = get_arg_int_value \"-%s\"  " arg arg), arg::env 
      | MacStringArg (lig, arg) ->
	  (Printf.sprintf "_%s = get_arg_string_value \"-%s\"  " arg arg), arg::env
    in 
    (accustr ^ ";;\nlet "^ml_decl, new_env)
  in
  let (res, _) = List.fold_left f_fold ("",[]) macroBP_list in
  if String.length res > 3
  then ((String.sub res 3 ((String.length res) - 4))^";;\n")
  else res
(* ===================================================================== *)

(* ===================================================================== *)
(** Produire les macros : prefixée par _ (FxCop n'est pas d'accord) 
    Raison : la plupart des macros commencent par une majuscule. *)
(* ===================================================================== *)
(* OBSOLETE : on ne peut pas calculer statiquement les macros, puisque 
   certaines dependent des arguments d'execution
   let ocaml_macro env = 
   let f (var, value) = Printf.sprintf "let _%s = %d;;\n" var value in 
   List.fold_left (fun accu i -> accu ^ (f i)) "" env;;
*)
(* ===================================================================== *)

(* ===================================================================== *)
(** Etant donnee une string, on veut savoir combien de \n elle comporte *)
(* ===================================================================== *)
let num_line c = 
  let nb = ref 0 in
  for i = 0 to pred (String.length c) do 
    if c.[i] = '\n' then incr(nb) else () 
  done; !nb;;
(* ===================================================================== *)

(* ===================================================================== *)
(** Produire du code pour des ralentisseurs systemes régulier *)
(* ===================================================================== *)
let ocaml_ralentisseur_factory = "let whattimeisit () =\n\
\  let t = Unix.localtime (Unix.time ()) in\n\
\  float_of_int (t.Unix.tm_hour * 3600 + t.Unix.tm_min * 60 + t.Unix.tm_sec);;\n\
\n\
class sleeper periode whattime_option =\n\ 
object(this)\n\
\n\
\  val mutable start = 0.0\n\
\  val mutable gone = false\n\
\  val mutable n = 0\n\
\n\
\  method private go = \n\
\    begin\n\
\      n <- 0;\n\
\      if whattime_option \n\
\      then\n\
\        start <- (Unix.gettimeofday ()) -. (whattimeisit ())\n\
\      else\n\
\       start <- (Unix.gettimeofday ())	;\n\
\      gone <- true\n\
\    end\n\
\n\
\  method private wait p =\n\
\    if p > 0.0 \n\
\    then \n\
\      try\n\
\        ignore (Unix.select [] [] [] p) (* nanosleep tortueux *)\n\
\      with\n\
\        | Unix.Unix_error(_, \"select\", _) -> ()\n\
\    else ()\n\
\n\
\  method sleep =\n\
\    if gone\n\
\    then \n\
\      begin\n\
\        if n = max_int then this#go else ();\n\
\        n <- succ n;\n\
\        let avance = start +. ((float_of_int n)*.periode) -. (Unix.gettimeofday ())\n\
\        in this#wait avance\n\
\      end\n\
\    else this#go\n\
end;;\n\n";;
(* ===================================================================== *)
